home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 2010 April / PCWorld0410.iso / hity wydania / Ubuntu 9.10 PL / karmelkowy-koliberek-desktop-9.10-i386-PL.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / Symbol.pm < prev    next >
Encoding:
Perl POD Document  |  2009-10-01  |  2.0 KB  |  92 lines
  1. package Symbol;
  2.  
  3. BEGIN { require 5.005; }
  4.  
  5. require Exporter;
  6. @ISA = qw(Exporter);
  7. @EXPORT = qw(gensym ungensym qualify qualify_to_ref);
  8. @EXPORT_OK = qw(delete_package geniosym);
  9.  
  10. $VERSION = '1.06';
  11.  
  12. my $genpkg = "Symbol::";
  13. my $genseq = 0;
  14.  
  15. my %global = map {$_ => 1} qw(ARGV ARGVOUT ENV INC SIG STDERR STDIN STDOUT);
  16.  
  17. #
  18. # Note that we never _copy_ the glob; we just make a ref to it.
  19. # If we did copy it, then SVf_FAKE would be set on the copy, and
  20. # glob-specific behaviors (e.g. C<*$ref = \&func>) wouldn't work.
  21. #
  22. sub gensym () {
  23.     my $name = "GEN" . $genseq++;
  24.     my $ref = \*{$genpkg . $name};
  25.     delete $$genpkg{$name};
  26.     $ref;
  27. }
  28.  
  29. sub geniosym () {
  30.     my $sym = gensym();
  31.     # force the IO slot to be filled
  32.     select(select $sym);
  33.     *$sym{IO};
  34. }
  35.  
  36. sub ungensym ($) {}
  37.  
  38. sub qualify ($;$) {
  39.     my ($name) = @_;
  40.     if (!ref($name) && index($name, '::') == -1 && index($name, "'") == -1) {
  41.     my $pkg;
  42.     # Global names: special character, "^xyz", or other. 
  43.     if ($name =~ /^(([^a-z])|(\^[a-z_]+))\z/i || $global{$name}) {
  44.         # RGS 2001-11-05 : translate leading ^X to control-char
  45.         $name =~ s/^\^([a-z_])/'qq(\c'.$1.')'/eei;
  46.         $pkg = "main";
  47.     }
  48.     else {
  49.         $pkg = (@_ > 1) ? $_[1] : caller;
  50.     }
  51.     $name = $pkg . "::" . $name;
  52.     }
  53.     $name;
  54. }
  55.  
  56. sub qualify_to_ref ($;$) {
  57.     return \*{ qualify $_[0], @_ > 1 ? $_[1] : caller };
  58. }
  59.  
  60. #
  61. # of Safe.pm lineage
  62. #
  63. sub delete_package ($) {
  64.     my $pkg = shift;
  65.  
  66.     # expand to full symbol table name if needed
  67.  
  68.     unless ($pkg =~ /^main::.*::$/) {
  69.         $pkg = "main$pkg"    if    $pkg =~ /^::/;
  70.         $pkg = "main::$pkg"    unless    $pkg =~ /^main::/;
  71.         $pkg .= '::'        unless    $pkg =~ /::$/;
  72.     }
  73.  
  74.     my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
  75.     my $stem_symtab = *{$stem}{HASH};
  76.     return unless defined $stem_symtab and exists $stem_symtab->{$leaf};
  77.  
  78.     # free all the symbols in the package
  79.  
  80.     my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
  81.     foreach my $name (keys %$leaf_symtab) {
  82.         undef *{$pkg . $name};
  83.     }
  84.  
  85.     # delete the symbol table
  86.  
  87.     %$leaf_symtab = ();
  88.     delete $stem_symtab->{$leaf};
  89. }
  90.  
  91. 1;
  92.